home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / lib / misc.tcl < prev    next >
Encoding:
Text File  |  1998-02-01  |  9.8 KB  |  370 lines
  1. ##############################################################################
  2. # $Id: misc.tcl,v 1.14 1998/02/02 05:11:33 stewart Exp $
  3. #
  4. # misc.tcl - leftover uncategorized procedures
  5. #
  6. # Copyright (C) 1996-1997 Stewart Allen
  7. #
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the terms of the GNU General Public License
  10. # as published by the Free Software Foundation; either version 2
  11. # of the License, or (at your option) any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful,
  14. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. # GNU General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program; if not, write to the Free Software
  20. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ##############################################################################
  23. #
  24.  
  25. proc vTcl:util:greatest_of {numlist} {
  26.     set max 0
  27.     foreach i $numlist {
  28.         if {$i > $max} {
  29.             set max $i
  30.         }
  31.     }
  32.     return $max
  33. }
  34.  
  35. proc vTcl:upper_first {string} {
  36.     set s [string toupper [string range $string 0 0]]
  37.     set l [string range $string 1 end]
  38.     return "${s}${l}"
  39. }
  40.  
  41. proc vTcl:lower_first {string} {
  42.     set s [string tolower [string range $string 0 0]]
  43.     set l [string range $string 1 end]
  44.     return "${s}${l}"
  45. }
  46.  
  47. proc vTcl:load_images {} {
  48.     global vTcl
  49.  
  50.     foreach i {fg bg mgr_grid mgr_pack mgr_place
  51.                 rel_groove rel_ridge rel_raised rel_sunken justify
  52.                 relief border ellipses anchor fontbase fontsize fontstyle} {
  53.         image create photo "$i" \
  54.             -file [file join $vTcl(VTCL_HOME) images $i.gif]
  55.     }
  56.     foreach i {n s e w nw ne sw se c} {
  57.         image create photo "anchor_$i" \
  58.             -file [file join $vTcl(VTCL_HOME) images anchor_$i.ppm]
  59.     }
  60.     image create bitmap "file_down" \
  61.         -file [file join $vTcl(VTCL_HOME) images down.xbm]
  62. }
  63.  
  64. proc vTcl:list {cmd elements list} {
  65.     upvar $list nlist
  66.     switch $cmd {
  67.         add {
  68.             foreach i $elements {
  69.                 if {[lsearch -exact $nlist $i] < 0} {
  70.                     lappend nlist $i
  71.                 }
  72.             }
  73.         }
  74.         delete {
  75.             foreach i $elements {
  76.                 set n [lsearch -exact $nlist $i]
  77.                 if {$n > -1} {
  78.                     set nlist [lreplace $nlist $n $n]
  79.                 }
  80.             }
  81.         }
  82.     }
  83.     return $nlist
  84. }
  85.  
  86. proc vTcl:diff_list {oldlist newlist} {
  87.     set output ""
  88.     foreach oldent $oldlist {
  89.         set oldar($oldent) 1
  90.     }
  91.     foreach newent $newlist {
  92.         if {[info exists oldar($newent)] == 0} {
  93.             lappend output $newent
  94.         }
  95.     }
  96.     return [lsort $output]
  97. }
  98.  
  99. proc vTcl:clean_pairs {list {indent 8}} {
  100.     global vTcl
  101.     set tab [string range "                " 0 [expr $indent - 1]]
  102.     set index $indent
  103.     set output $tab
  104.     set last ""
  105.     foreach i $list {
  106.         if {$last == ""} {
  107.             set last $i
  108.         } else {
  109.             switch $vTcl(pr,encase) {
  110.                 list {
  111.                     set i "$last [list $i] "
  112.                 }
  113.                 brace {
  114.                     set i "$last \{$i\} "
  115.                 }
  116.                 quote {
  117.                     set i "$last \"$i\" "
  118.                 }
  119.             }
  120.             set last ""
  121.             set len [string length $i]
  122.             if { [expr $index + $len] > 78 } {
  123.                 append output "\\\n${tab}${i}"
  124.                 set index [expr $indent + $len]
  125.             } else {
  126.                 append output "$i"
  127.                 incr index $len
  128.             }
  129.         }
  130.     }
  131.     return $output
  132. }
  133.  
  134. #############################
  135. # Setting Widget Properties #
  136. #############################
  137. proc vTcl:bounded_incr {var delta} {
  138.     upvar $var newvar
  139.     set newval [expr $newvar + $delta]
  140.     if {$newval < 0} {
  141.         set newvar 0
  142.     } else {
  143.         set newvar $newval
  144.     }
  145. }
  146.  
  147. proc vTcl:pos_neg {num} {
  148.     if {$num > 0} {return 1}
  149.     if {$num < 0} {return -1}
  150.     return 0
  151. }
  152.  
  153. proc vTcl:widget_delta {widget x y w h} {
  154.     global vTcl
  155.     switch $vTcl(w,manager) {
  156.         grid {
  157.             vTcl:bounded_incr vTcl(w,grid,-column) [vTcl:pos_neg $x]
  158.             vTcl:bounded_incr vTcl(w,grid,-row) [vTcl:pos_neg $y]
  159.             vTcl:bounded_incr vTcl(w,grid,-columnspan) [vTcl:pos_neg $w]
  160.             vTcl:bounded_incr vTcl(w,grid,-rowspan) [vTcl:pos_neg $h]
  161.             vTcl:manager_update grid
  162.         }
  163.         pack {
  164.             if {$x < 0 || $y < 0} {vTcl:pack_before $vTcl(w,widget)}
  165.             if {$x > 0 || $y > 0} {vTcl:pack_after $vTcl(w,widget)}
  166.         }
  167.         place {
  168.             set newX [expr [winfo x $widget] + $x]
  169.             set newY [expr [winfo y $widget] + $y]
  170.             set newW [expr [winfo width $widget] + $w]
  171.             set newH [expr [winfo height $widget] + $h]
  172.             set do "place $vTcl(w,widget) -x $newX -y $newY \
  173.                 -width $newW -height $newH -bordermode ignore"
  174.             set undo [vTcl:dump_widget_quick $widget]
  175.             vTcl:push_action $do $undo
  176.         }
  177.     }
  178.     vTcl:place_handles $widget
  179. }
  180.  
  181. ##############################################################################
  182. # OTHER PROCEDURES
  183. ##############################################################################
  184. proc vTcl:hex {num} {
  185.     if {$num == ""} {set num 0}
  186.     set textnum [format "%x" $num]
  187.     if { $num < 16 } { set textnum "0${textnum}" }
  188.     return $textnum
  189. }
  190.  
  191. proc vTcl:grid_snap {xy pos} {
  192.     global vTcl
  193.     if { $vTcl(w,manager) != "place" } { return $pos }
  194.     set off [expr $pos % $vTcl(grid,$xy)]
  195.     if { $off > 0 } {
  196.         return [expr $pos - $off]
  197.     } else {
  198.         return $pos
  199.     }
  200. }
  201.  
  202. proc vTcl:status {message} {
  203.     global vTcl
  204.     set vTcl(status) $message
  205.     update idletasks
  206. }
  207.  
  208. proc vTcl:right_click {widget x y} {
  209.     global vTcl
  210.     $vTcl(gui,rc_menu) post $x $y
  211.     grab $vTcl(gui,rc_menu)
  212.     bind $vTcl(gui,rc_menu) <ButtonRelease> {
  213.         grab release $vTcl(gui,rc_menu)
  214.         $vTcl(gui,rc_menu) unpost
  215.     }
  216. }
  217.  
  218. proc vTcl:statbar {value} {
  219.     global vTcl
  220.     set w [expr [winfo width [winfo parent $vTcl(gui,statbar)]] - 4]
  221.     set h [expr [winfo height [winfo parent $vTcl(gui,statbar)]] - 4]
  222.     set mult [expr ${w}.0 / 100.0]
  223.     if {$value == 0} {
  224.         place forget $vTcl(gui,statbar)
  225.     } else {
  226.         place $vTcl(gui,statbar) -x 1 -y 1 -width [expr $value * $mult] -height $h
  227.     }
  228.     update idletasks
  229. }
  230.  
  231. proc vTcl:show_bindings {} {
  232.     global vTcl
  233.     if {$vTcl(w,widget) != ""} {
  234.         Window show .vTcl.bind
  235.         vTcl:get_bind $vTcl(w,widget)
  236.     } else {
  237.         vTcl:dialog "No widget selected!"
  238.     }
  239. }
  240.  
  241. proc vTcl:rename {name} {
  242.     regsub -all "\\." $name "_" ret
  243.     regsub -all "\\-" $ret "_" ret2
  244.     return $ret2
  245. }
  246.  
  247. proc vTcl:cmp_user_menu {} {
  248.     global vTcl
  249.     #set m $vTcl(gui,main).menu.c.m.m.u
  250.     set m $vTcl(menu,user,m)
  251.     catch {destroy $m}
  252.     menu $m -tearoff 0
  253.     foreach i [lsort $vTcl(cmpd,list)] {
  254.         $m add comm -label $i -comm "
  255.             vTcl:put_compound \$vTcl(cmpd:$i)
  256.         "
  257.     }
  258. }
  259.  
  260. proc vTcl:cmp_sys_menu {} {
  261.     global vTcl
  262. #    set m $vTcl(gui,main).menu.c.m.m.s
  263.     set m $vTcl(menu,system,m)
  264.     catch {destroy $m}
  265.     menu $m -tearoff 0
  266.     foreach i [lsort $vTcl(syscmpd,list)] {
  267.         $m add comm -label $i -comm "
  268.             vTcl:put_compound \$vTcl(syscmpd:$i)
  269.         "
  270.     }
  271. }
  272.  
  273. proc vTcl:get_children {target} {
  274.     global vTcl
  275.     set r ""
  276.     set all [winfo children $target]
  277.     set n [pack slaves $target]
  278.     if {$n != ""} {
  279.         foreach i $all {
  280.             if {[lsearch -exact $n $i] < 0} {
  281.                 lappend n $i
  282.             }
  283.         }
  284.     } else {
  285.         set n $all
  286.     }
  287.     foreach i $n {
  288.         if ![string match ".__tk*" $i] {
  289.             lappend r $i
  290.         }
  291.     }
  292.     return $r
  293. }
  294.  
  295. proc vTcl:find_new_tops {} {
  296.     global vTcl
  297.     set new ""
  298.     foreach i $vTcl(procs) {
  299.         if [string match $vTcl(winname).* $i] {
  300.             set n [string range $i 10 end]
  301.             if {$n != "."} {
  302.                 lappend new [string range $i 10 end]
  303.             }
  304.         }
  305.     }
  306.     foreach i [vTcl:list_widget_tree .] {
  307.         if {[winfo class $i] == "Toplevel"} {
  308.             if {[lsearch $new $i] < 0} {
  309.                 lappend new $i
  310.             }
  311.         }
  312.     }
  313.     return $new
  314. }
  315.  
  316. proc vTcl:error {mesg} {
  317.     vTcl:dialog $mesg
  318. }
  319.  
  320. proc vTcl:dialog {mesg {options Ok} {root 0}} {
  321.     global vTcl tcl_platform
  322.     set vTcl(x_mesg) ""
  323.     if {$root == 0} {
  324.         set base .vTcl.message
  325.     } else {
  326.         set base .vTcl:message
  327.     }
  328.     set sw [winfo screenwidth .]
  329.     set sh [winfo screenheight .]
  330.     if {![winfo exists $base]} {
  331.         toplevel $base -class vTcl
  332.         wm title $base "Visual Tcl Message"
  333.         wm transient $base .vTcl
  334.         frame $base.f -bd 2 -relief groove
  335.         label $base.f.t -bd 0 -relief flat -text $mesg -justify left \
  336.             -font $vTcl(pr,font_dlg)
  337.         frame $base.o -bd 1 -relief sunken
  338.         foreach i $options {
  339.             set n [string tolower $i]
  340.             button $base.o.$n -text $i -width 5 \
  341.             -command "
  342.                 set vTcl(x_mesg) $i
  343.                 destroy $base
  344.             "
  345.             pack $base.o.$n -side left -expand 1 -fill x
  346.         }
  347.         pack $base.f.t -side top -expand 1 -fill both -ipadx 5 -ipady 5
  348.         pack $base.f -side top -expand 1 -fill both -padx 2 -pady 2
  349.         pack $base.o -side top -fill x -padx 2 -pady 2
  350.     }
  351.     wm withdraw $base
  352.     update idletasks
  353.     set w [winfo reqwidth $base]
  354.     set h [winfo reqheight $base]
  355.     set x [expr ($sw - $w)/2]
  356.     set y [expr ($sh - $h)/2]
  357.     if {$tcl_platform(platform) != "unix"} {
  358.         wm deiconify $base
  359.     }
  360.     wm geometry $base +$x+$y
  361.     if {$tcl_platform(platform) == "unix"} {
  362.         wm deiconify $base
  363.     }
  364.     grab $base
  365.     tkwait window $base
  366.     grab release $base
  367.     return $vTcl(x_mesg)
  368. }
  369.  
  370.